(setq *rset t)

(declare (mapex t)
         (special **exp** **env** **unevlis** **evlis** **pc** **clink** **val** **tem**
                  **top** **queue** **tick** **quantum** **process**
                  version lispversion))

(defun version macro (x)
       (cond (compiler-state (list 'quote
				   ((lambda (ur)
					    (cond ((atom (car ur))
						   (cadr ur))
						  (t (caddr ur))))
				    (status uread))))
	     (t (rplaca x 'quote)
		(rplacd x (list version))
		(list 'quote version))))

(declare (read))

(setq version ((lambda (compiler-state) (version)) t))

(defun fastcall (atsym)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym))))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr))
			       (t (apply atsym nil))))
		 (get atsym 'subr)))))

(defun fastcall3 (atsym arg1 arg2 arg3)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym)) arg1 arg2 arg3))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr arg1 arg2 arg3))
			       (t (funcall atsym arg1 arg2 arg3))))
		 (get atsym 'subr)))))

(defun try fexpr (x)
       (setq **exp** nil  **env** nil  **clink** nil  **unevlis** nil  **evlis** nil)
       (setq **queue** nil  **process** (gensym))
       (dispatch (car x) nil 'terminate)
       (alarmclock 'runtime **quantum**)
       (mloop))

(defun scheme ()
       (setq version (version))
       (setq lispversion (status lispversion))
       (try (labels ((**top**
		      (lambda ()
			     (progn (terpri)
				    (princ '|==> |)
				    (print (set '* (evaluate (read))))
				    (**top**)))))
		    (progn (terpri)
			   (princ '|This is SCHEME - fast |)
			   (princ version)
			   (princ '| running in LISP |)
			   (princ lispversion)
                           (set '**top** **top**)
			   (**top**)))))

(defun mloop ()
       (do ((**tick** nil))  (nil)
          (and **tick** (allow) (schedule))
          (fastcall **pc**)))

(defun allow ()
  ((lambda (vcell)
       (cond (vcell (car vcell))
             (t t)))
   (lookup '*allow* **env**)))

(defun schedule ()
       ((lambda (oldint)
                (cond (**queue**
                       (putprop **process** (saveup **pc**) 'clink)
                       (putprop **process** **val** 'val)
                       (nconc **queue** (list **process**))
                       (setq **process** (car **queue**)
                             **clink** (get **process** 'clink)
                             **val** (get **process** 'val)
                             **queue** (cdr **queue**))
                       (restore)))
                (setq **tick** nil)
                (alarmclock 'runtime **quantum**)
                (nointerrupt oldint))
        (nointerrupt t)))

(defun settick (x) (setq **tick** t))
(setq **quantum** 1000000. alarmclock 'settick)

(defprop evaluate aeval aint)

(defun aeval (exp1 env1 retag)
       (saveup retag)
       (setq **evlis** env1)
       (dispatch (cadr exp1) env1 'aeval1))

(defun aeval1 ()
       (restore)
       (dispatch **val** **evlis** **pc**))

(defun dispatch (exp1 env1 retag)
   (prog (tem1)
    lp (cond ((atom exp1)
              (cond ((numberp exp1)
                     (setq **val** exp1  **pc** retag))
                    ((primop exp1)
                     (setq **val** exp1  **pc** retag))
                    ((setq tem1 (lookup exp1 env1))
                     (setq **val** (car tem1)  **pc** retag))
                    (t (setq **val** (symeval exp1)  **pc** retag))))
             ((eq (car exp1) 'lambda)
              (setq **val** (list 'beta exp1 env1)  **pc** retag))
             ((atom (car exp1))
              (cond ((setq tem1 (get (car exp1) 'aint))
                     (fastcall3 tem1 exp1 env1 retag))
                    ((setq tem1 (get (car exp1) 'amacro))
                     (setq exp1 (funcall tem1 exp1))
                     (go lp))
                    (t (saveup retag)
                       (setq **evlis** (list (cond ((primop (car exp1)) (car exp1))
                                               ((setq tem1 (lookup (car exp1) env1))
                                                (car tem1))
                                               (t (symeval (car exp1)))))
                             **unevlis** (cdr exp1)
			     **exp** exp1
                             **env** env1
                             **pc** 'evlis1))))
             ((eq (caar exp1) 'lambda)
              (saveup retag)
              (setq **evlis** (list (car exp1))
		    **unevlis** (cdr exp1)
                    **exp** exp1
                    **env** env1
                    **pc** 'evlis1))
             (t (saveup retag)
                (setq **exp** exp1  **env** env1
		      **evlis** nil  **unevlis** exp1
		      **pc** 'evlis1)))))

(defun evlis1 ()
       (cond ((null **unevlis**)
              (prog (fn env1 arghs)
                    (setq fn (car (last **evlis**))  arghs **evlis**)
                    (cond ((primop fn)
                           (restore)
                           (setq **val** (apply fn (cdr (reverse arghs)))))
                          ((eq (car fn) 'lambda)
                           (setq env1 **env**)
                           (restore)
                           (dispatch (caddr fn)
                                     (pairify1 (cadr fn) arghs env1)
                                     **pc**))
                          ((eq (car fn) 'beta)
                           (restore)
                           (dispatch (caddr (cadr fn))
                                     (pairify1 (cadr (cadr fn))
                                              arghs
                                              (caddr fn))
                                     **pc**))
                          ((eq (car fn) 'delta)
                           (setq **clink** (cadr fn))
                           (restore))
                          (t (error '|Bad Function - Evarglist| **exp** 'fail-act)))))
             (t (dispatch (car **unevlis**) **env** 'evlis2))))

(defun evlis2 ()
   (setq **evlis** (cons **val** **evlis**)  **unevlis** (cdr **unevlis**)  **pc** 'evlis1))

(defprop if aif aint)

(defun aif (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'if1))

(defun if1 ()
   (prog (exp1 env1)
       (setq exp1 **exp**  env1 **env**)
       (restore)
       (cond (**val** (dispatch (caddr exp1) env1 **pc**))
             (t (dispatch (cadddr exp1) env1 **pc**)))))

(defprop quote aquote aint)

(defun aquote (exp1 env1 retag)
       (setq **val** (cadr exp1)  **pc** retag))

(defprop labels alabels aint)

(defun alabels (exp1 env1 retag)
       (setq env1 (cons nil env1))
       (rplaca env1
	       (list (mapcar 'car (cadr exp1))
		     (do ((x (cadr exp1) (cdr x))
			  (z nil (cons (list 'beta (cadar x) env1) z)))
			 ((null x) z))))
       (dispatch (caddr exp1) env1 retag))

(defprop define adefine aint)

(defun adefine (exp1 env1 retag)
       (set (cadr exp1) (list 'beta  (caddr exp1) nil))
       (setq **val** (cadr exp1)  **pc** retag))

(defprop aset aaset aint)

(defun aaset (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'aaset1))

(defun aaset1 ()
       (setq **evlis** **val**)
       (dispatch (caddr **exp**) **env** 'aaset2))

(defun aaset2 ()
       (setq **tem** (lookup **evlis** **env**))
       (cond (**tem** (rplaca **tem** **val**))
             (t (set **evlis** **val**)))
       (restore))

(defun create!process (exp1)
       ((lambda (**clink** **env** **pc** **evlis** **val**)
                (dispatch exp1 **env** 'terminate)
                (setq **tem** (gensym))
                (putprop **tem** (saveup **pc**) 'clink)
                (putprop **tem** **val** 'val)
                **tem**)
        **clink** **env** **pc** **evlis** **val**))

(defun start!process (p)
    (cond ((or (eq p **process**) (memq p **queue**))
           (error '|Process already running -- Start!process| p 'fail-act))
          ((or (not (atom p)) (not (get p 'clink)))
           (error '|Bad process -- Start!process| p 'fail-act)))
    ((lambda (oldint) 
             (setq **queue** (nconc **queue** (list p)))
             (nointerrupt oldint)
             p)
     (nointerrupt t)))

(defun stop!process (p)
    (cond ((memq p **queue**)
           ((lambda (oldint)
		    (setq **queue** (delete p **queue**))
		    (nointerrupt oldint)
		    p)
	    (nointerrupt t)))
          ((eq p **process**) (terminate))
          (t (error '|Bad process -- Stop!process| p 'fail-act))))

(defun terminate ()
       ((lambda (oldint)
                (cond ((null **queue**)
                       (print 'Done!)
                       (setq **clink** nil)
                       (dispatch '(**top**) nil 'terminate))
                      (t (setq **process** (car **queue**)
                               **clink** (get **process** 'clink)
                               **val** (get **process** 'val)
                               **queue** (cdr **queue**))
                         (restore)))
                (nointerrupt oldint)
                **val**)
        (nointerrupt t)))

(defprop evaluate!uninterruptibly evun aint)

(defun evun (exp1 env1 retag)
   (dispatch (cadr exp1) (pairify '(**allow**) (list nil) env1) retag))

(defprop catch acatch aint)

(defun acatch (exp1 env1 retag)
       (dispatch (caddr exp1)
		 (pairify (list (cadr exp1))
			  (list (list 'delta
				       ((lambda (**clink**) (saveup retag))
					**clink**)))
			  env1)
                 retag))

(declare (read) (read)) (read)

(defun lookup (var env)
       (do ((e env (cdr e)) (vc nil))
	   ((null e) vc)
	   (do ((vl (caar e) (cdr vl)))
	       ((null vl))
	       (and (eq (car vl) var)
		    (do ((j 0 (1+ j))
			 (z vl (cdr z)))
			((null z)
			 (setq vc (do ((k 1 (1+ k))
				       (x (cadar e) (cdr x)))
				      ((= k j) x)
				      (declare (fixnum k))))
			 (setq e nil))
			(declare (fixnum j)))))))

(declare (read) (read)) (read)

(defun lookup (var env)
       (do ((e env (cdr e))
	    (vc nil)
	    (j 0))
	   ((null e) vc)
	   (declare (fixnum j))
	   (setq j (do ((i 0 (1+ i))
			(l (caar e) (cdr l)))
		       ((null l) i)
		       (declare (fixnum i))
		       (cond ((eq (car l) var)
			      (setq vc t)
			      (setq i 0)))))
	   (cond (vc (do ((k j (1- k))
			  (l (cadar e) (cdr l)))
			 ((= k 1) (setq vc l) (setq e nil))
			 (declare (fixnum k)))))))

(lap lookup subr)
(args lookup (nil . 2))
loop1	(jumpe b lose)
	(hlrz c 0 b)
	(hlrz ar1 0 c)
loop2	(jumpe ar1 again)
	(hlrz ar2a 0 ar1)
	(cain ar2a 0 a)
	 (jrst 0 win)
	(hrrz ar1 0 ar1)
	(jrst 0 loop2)
win	(movei tt 1)
loop3	(hrrz ar1 0 ar1)
	(jumpe ar1 hack)
	(aoja tt loop3)
hack	(hrrz a 0 c)
	(hlrz a 0 a)
loop4	(soje tt done)
	(hrrz a 0 a)
	(jrst 0 loop4)
again	(hrrz b 0 b)
	(jrst 0 loop1)
lose	(movei a 'nil)
done	(popj p)
nil 

(defun pairify (x y z)
       (cond ((and *rset (not (= (length x) (length y))))
	      (error '|Wrong Number of Arguments|
		      **exp**
		      'wrng-no-args))
	     (t (cons (list x y) z))))

(defun pairify1 (x y z)
       (cond ((and *rset (not (= (length x) (length (cdr y)))))
	      (error '|Wrong Number of Arguments|
		      **exp**
		      'wrng-no-args))
	     (t (cons (list x y) z))))

(defun primop (x) (getl x '(subr expr lsubr)))

(defun saveup (retag)
       (setq **clink** (list **exp** **env** **unevlis** **evlis** retag **clink**)))

(defun restore ()
  (prog (ltem)
       (setq ltem (or **clink**
		     (error '|Process Ran Out - Restore|
			     **exp**
			     'fail-act))
             **exp** (car ltem)
              ltem (cdr ltem)
             **env** (car ltem)
              ltem (cdr ltem)
             **unevlis** (car ltem)
              ltem (cdr ltem)
             **evlis** (car ltem)
              ltem (cdr ltem)
             **pc** (car ltem)
              ltem (cdr ltem)
             **clink** (car ltem))))
ββ